home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / dbm.scm < prev    next >
Text File  |  1995-10-13  |  14KB  |  391 lines
  1. ;;; DBM processing code
  2.  
  3. ;;; Copyright (c) 1995 by David Albertz (dalbertz@clark.lcs.mit.edu).
  4.  
  5. ;;; This code is freely available for use by anyone for any purpose,
  6. ;;; so long as you don't charge money for it, remove this notice, or
  7. ;;; hold us liable for any results of its use.  --enjoy.
  8.  
  9. ;;; Usage:    (dbm-open name flags mode . access_method access_info)
  10. ;;;                 name          := name of database file (no extension)
  11. ;;;                 flags         := file access flags (open/create etc.)
  12. ;;;                 mode          := file access modes (privileges)
  13. ;;;                 access_method := *if* you have Berkeley dbm, then
  14. ;;;                         you can specify btree, hash, or
  15. ;;;                         recno access methods (0, 1, or 2)
  16. ;;;                 access_info   := *if* you have Berkeley dbm, then
  17. ;;;                         you can specify an access information
  18. ;;;                         record, which must correspond to the
  19. ;;;                         correct access method.
  20. ;;;             *Note*: If you do *not* have Berkeley dbm, then specifying
  21. ;;;                     access_method and/or access_info will generate an
  22. ;;;                     error.  If access_method is omitted and you *do*
  23. ;;;                     have Berkeley dbm, the default is btree.
  24.  
  25. ;;; Return:    dbm-record which contains the Alien value pointer
  26. ;;;                        to the open DBM structure and an open
  27. ;;;                        status flag set to #t.
  28.  
  29.  
  30. ;;; Usage:      (dbm-close db)
  31. ;;;                 db := The dbm-record returned by dbm-open
  32.  
  33. ;;; Return:     Return value is undefined
  34.  
  35.  
  36. ;;; Usage:      (dbm-fetch db key)
  37. ;;;                 db  := The dbm-record returnd by dbm-open
  38. ;;;                 key := The key value of data to be retrieved
  39.  
  40. ;;; Return:     String containing data associated with key
  41.  
  42.  
  43. ;;; Usage:      (dbm-insert db key data)
  44. ;;;                 db   := The dbm-record returned by dbm-open
  45. ;;;                 key  := The key value to be associated with data
  46. ;;;                 data := The data to be stored with the key
  47. ;;;             Note: Insert will return an error if you try to
  48. ;;;                   insert a duplicate key into the database
  49.  
  50. ;;; Return:     Return value is undefined
  51.  
  52. ;;; Usage:      (dbm-replace db key data)
  53. ;;;                 db   := The dbm-record returned by dbm-open
  54. ;;;                 key  := The key value whose data is to be changed
  55. ;;;                 data := The data to be stored with the key
  56. ;;;             Note: If you try to replace the data for a non-existent
  57. ;;;                   key, dbm-replace will act like dbm-insert
  58.  
  59. ;;; Return:     Return value is undefined
  60.  
  61.  
  62. ;;; Usage:      (dbm-delete db key)
  63. ;;;                 db  := The dbm-record returned by dbm-open
  64. ;;;                 key := The key value of data to be deleted
  65.  
  66. ;;; Return:     Integer returned by UNIX dbm_delete routine
  67.  
  68.  
  69. ;;; Usage:      (dbm-firstkey db)
  70. ;;;                 db   := The dbm-record returned by dbm-open
  71.  
  72. ;;; Return:     First key value stored in database hash table.
  73.  
  74.  
  75. ;;; Usage:      (dbm-nextkey db)
  76. ;;;                 db   := The dbm-record returned by dbm-open
  77.  
  78. ;;; Return:     Next key value stored in database hash table.
  79. ;;;             Returns the null string when there are no more keys.
  80.  
  81.  
  82. ;;; If a database error is detected during any read or write operation,
  83. ;;; the error number returned by the UNIX dbm_error routine is passed
  84. ;;; back as an error condition.
  85.  
  86. ;;; ***NOTE:  All key and data elements must be strings
  87.  
  88. ;;; Scheme48 implementation.
  89.  
  90. (foreign-source
  91.   "#include <sys/types.h>"
  92.   "#include <limits.h>"
  93.   "#include <ndbm.h>"
  94.   "#include <db.h>"
  95.   ""
  96.   "extern int errno;"
  97.   ""
  98.   "#define errno_or_false(x) (((x) == -1) ? ENTER_FIXNUM(errno) : SCHFALSE)"
  99.   "" "")
  100.  
  101. ;;; This record will hold the pointer the the dbm structure plus
  102. ;;; a boolean flag with open status information
  103. (define-record dbm-record
  104.   open?
  105.   dbm)
  106.  
  107. ;;; Use this record to pass btree access method specific data to dbm-open
  108. (define-record btree-info
  109.   flags
  110.   cachesize
  111.   maxkeypage
  112.   minkeypage
  113.   psize
  114.   lorder)
  115.  
  116. ;;; Use this record to pass hash access method specific data to dbm-open
  117. (define-record hash-info
  118.   bsize
  119.   ffactor
  120.   nelem
  121.   cachesize
  122.   lorder)
  123.  
  124. ;;; Use this record to pass recno access method specific data to dbm-open
  125. (define-record recno-info
  126.   flags
  127.   cachesize
  128.   psize
  129.   lorder
  130.   reclen
  131.   bval
  132.   bfname)
  133.  
  134. ;;; Internal routine returns true if Berkeley dbm code is available
  135. (define-foreign %db-check (db_check)
  136.   bool)
  137.  
  138. ;;; If you don't specifiy an access method, this is the default
  139. ;;; internal routine that will be called.  The only one you can
  140. ;;; use if you don't have Berkely dbm.
  141. (define-foreign %dbm-open (db_open_default (string file)
  142.                        (integer flags)
  143.                        (integer mode))
  144.   (to-scheme integer errno_or_false) ; error flag
  145.   (C DB**)) ; DB structure
  146.  
  147. ;;; Internal routine to open btree database
  148. (define-foreign %dbm-open-btree (db_open_btree (string file)
  149.                            (integer flags)
  150.                            (integer mode)
  151.                            (integer pass-info?)
  152.                            (integer access-flags)
  153.                            (integer cachesize)
  154.                            (integer maxkeypage)
  155.                            (integer minkeypage)
  156.                            (integer psize)
  157.                            (integer lorder))
  158.   (to-scheme integer errno_or_false) ; error flag
  159.   (C DB**)) ; DB structure
  160.  
  161. ;;; Internal routine to open hash database
  162. (define-foreign %dbm-open-hash (db_open_hash (string file)
  163.                          (integer flags)
  164.                          (integer mode)
  165.                          (integer pass-info?)
  166.                          (integer bsize)
  167.                          (integer ffactor)
  168.                          (integer nelem)
  169.                          (integer cachesize)
  170.                          (integer lorder))
  171.   (to-scheme integer errno_or_false) ; error flag
  172.   (C DB**)) ; DB structure
  173.  
  174. ;;; Internal routine to open recno database
  175. (define-foreign %dbm-open-recno (db_open_recno (string file)
  176.                            (integer flags)
  177.                            (integer mode)
  178.                            (integer pass-info?)
  179.                            (integer access-flags)
  180.                            (integer cachesize)
  181.                            (integer psize)
  182.                            (integer lorder)
  183.                            (integer reclen)
  184.                            (char bval)
  185.                            (string bfname))
  186.   (to-scheme integer errno_or_false) ; error flag
  187.   (C DB**)) ; DB structure
  188.  
  189. ;;; Convenient names for the access methods - these are exported
  190. (define btree/method 0)
  191. (define hash/method 1)
  192. (define recno/method 2)
  193.  
  194.  
  195. ;;; Several utility routines to help parse optional parameters
  196. (define (maybe-car lst)
  197.   (if (pair? lst)
  198.       (car lst)
  199.       #f))
  200.  
  201. (define (maybe-cdr lst)
  202.   (if (pair? lst)
  203.       (cdr lst)
  204.       #f))
  205.  
  206. (define (maybe-cadr lst)
  207.   (maybe-car (maybe-cdr lst)))
  208.  
  209. ;;; This routine returns to correct internal %dbm-open-foo routine
  210. ;;; based on the specified access method.  If Berkeley dbm is not
  211. ;;; present on the system it will return an error condition if
  212. ;;; any access method is specified.
  213. (define (get-access-method access-parms)
  214.   (let ((Berkeley? (%db-check))
  215.     (access-method (maybe-car access-parms)))
  216.     (if (and (not Berkeley?) access-method)
  217.     (error "You need the Berkeley dbm library - it's free!")
  218.     (cond ((equal? access-method btree/method) %dbm-open-btree)
  219.           ((equal? access-method hash/method)  %dbm-open-hash)
  220.           ((equal? access-method recno/method) %dbm-open-recno)
  221.           ((not access-method)                 %dbm-open)
  222.           (else (error "Invalid access method specified"))))))
  223.  
  224. ;;; This routine checks for an optional access method specific information
  225. ;;; record (btree-info, hash-info, or recno-info).  It returns an error
  226. ;;; condition of the record type does not match the access method.
  227. ;;; Case 1: no access method or access info record provided
  228. ;;;         Return the empty list
  229. ;;; Case 2: Access method provided but not the info record
  230. ;;;         Return a list with 0 as the first element
  231. ;;;                  and the correct number of remaining
  232. ;;;                  elements for the specified access method.
  233. ;;;                  The values in these elements are arbitrary.
  234. ;;; Case 3: Both access method and access info record provided
  235. ;;;         Return a list with 1 as the first element and
  236. ;;;         the individual fields within the info record as
  237. ;;;         the remaining elements in the list.
  238. ;;;
  239. ;;; The resulting list will be used for application of the %dbm-open-foo
  240. (define (get-access-data access-parms)
  241.   (let ((access-method (maybe-car  access-parms))
  242.     (access-info   (maybe-cadr access-parms)))
  243.     (cond ((btree-info? access-info)
  244.        (if (eqv? access-method btree/method)
  245.            (list 1
  246.              (btree-info:flags      access-info)
  247.              (btree-info:cachesize  access-info)
  248.              (btree-info:maxkeypage access-info)
  249.              (btree-info:minkeypage access-info)
  250.              (btree-info:psize      access-info)
  251.              (btree-info:lorder     access-info))
  252.            (error "Invalid access method for btree information")))
  253.       ((hash-info? access-info)
  254.        (if (eqv? access-method hash/method)
  255.            (list 1
  256.              (hash-info:bsize     access-info)
  257.              (hash-info:ffactor   access-info)
  258.              (hash-info:nelem     access-info)
  259.              (hash-info:cachesize access-info)
  260.              (hash-info:lorder    access-info))
  261.            (error "Invalid access method for hash information")))
  262.       ((recno-info? access-info)
  263.        (if (eqv? access-method recno/method)
  264.            (list 1
  265.              (recno-info:flags access-info)
  266.              (recno-info:cachesize access-info)
  267.              (recno-info:psize     access-info)
  268.              (recno-info:lorder    access-info)
  269.              (recno-info:reclen    access-info)
  270.              (recno-info:bval      access-info)
  271.              (recno-info:bfname    access-info))
  272.            (error "Invalid access method for recno information")))
  273.       ((not access-info)
  274.        (cond ((eqv? access-method btree/method)
  275.           (list 0 0 0 0 0 0 0))
  276.          ((equal? access-method hash/method)
  277.           (list 0 0 0 0 0 0))
  278.          ((eqv? access-method recno/method)
  279.           (list 0 0 0 0 0 0 #\0 ""))
  280.          ((not access-method)
  281.           '())
  282.          (else (error "Invalid access method specified"))))
  283.       (else (error "Invalid access information specified")))))
  284.  
  285. ;;; The visible version of the dbm-open routine
  286. ;;; Returns error or a cons cell with the tag "dbm" in car
  287. ;;; and the alien value from %dbm-open-foo in cdr
  288. (define (dbm-open file flags mode . maybe-access)
  289.   (let ((access-method (get-access-method maybe-access))
  290.     (access-data   (append (list file flags mode)
  291.                    (get-access-data   maybe-access))))
  292.     (receive (err dbm) (apply access-method access-data)
  293.          (if err
  294.          (errno-error err dbm-open)
  295.          (make-dbm-record #t dbm)))))
  296.  
  297. ;;; Common utility routine that makes sure dbm is an open database
  298. (define (check-dbm dbm)
  299.   (check-arg dbm-record? dbm "Not a database")
  300.   (check-arg dbm-record:open? dbm "Database not open"))
  301.  
  302. ;;; Common utility routine to check for database errors
  303. ;;; result should be the result of applying the routine that might cause
  304. ;;; the error, e.g. (dbm-error dbm (%dbm-delete dbm key)) would
  305. ;;; give back the result of the delete, or an error if it occurred
  306. (define (dbm-error dbm result)
  307.   (let ((err (%dbm-error (dbm-record:dbm dbm))))
  308.     (if (= err 0)
  309.     result
  310.     (begin 
  311.       (%dbm-clearerr (dbm-record:dbm dbm))
  312.       (error "Database error" err)))))
  313.  
  314. ;;; Close routines.  Note that the cdr of a dbm cons cell is set to #f
  315. ;;; to prevent someone from issuing subsequent calls to that database
  316. ;;; without re-opening it.
  317. (define-foreign %dbm-close (dbm_close ((C DBM*) dbm))
  318.   integer);
  319.  
  320. (define (dbm-close dbm)
  321.   (%dbm-close (dbm-record:dbm (check-dbm dbm)))
  322.   (set-dbm-record:open? dbm #f))
  323.  
  324. ;;; Database error return.  Straight forward implementation of UNIX call
  325. ;;; If this returns zero, you can be confident that the previous call
  326. ;;; to the database worked correctly.
  327. (define-foreign %dbm-error (dbm_error ((C DBM*) dbm))
  328.   integer)
  329.  
  330. ;;;  Clear database errors.  Straight forward implementation of UNIX call
  331. ;;;  Resets database so dbm-error returns zero again.
  332. (define-foreign %dbm-clearerr (dbm_clearerr ((C DBM*) dbm))
  333.   integer)
  334.  
  335. ;;;  Delete key from database if it exists
  336. (define-foreign %dbm-delete (database_delete ((C DBM*) dbm)
  337.                         (string-desc key))
  338.   integer)
  339.  
  340. (define (dbm-delete dbm key)
  341.   (dbm-error dbm (%dbm-delete (dbm-record:dbm (check-dbm dbm)) key)))
  342.  
  343. ;;; Return the data associated with key if it exists, otherwise
  344. ;;; it returns a null string
  345. (define-foreign %dbm-fetch (database_fetch ((C DBM*) dbm)
  346.                       (string-desc key))
  347.   string)
  348.  
  349. (define (dbm-fetch dbm key)
  350.   (dbm-error dbm (%dbm-fetch (dbm-record:dbm (check-dbm dbm)) key)))
  351.  
  352. ;;; Store a new occurance of the associated <key,data> pair in the database
  353. ;;; if flags is zero, otherwise replace old data for key with new data
  354. (define-foreign %dbm-store (database_store ((C DBM*) dbm)
  355.                        (string-desc key)
  356.                        (string-desc data)
  357.                        (integer flags))
  358.   integer)
  359.  
  360. ;;; Insert a new occurance of <key,data> into database
  361. (define (dbm-insert dbm key data)
  362.   (let ((insret (dbm-error dbm
  363.                (%dbm-store (dbm-record:dbm (check-dbm dbm))
  364.                        key
  365.                        data
  366.                        0))))
  367.     (if (not (= insret 0))
  368.     (error "Attempt to insert duplicate key")
  369.     insret)))
  370.  
  371. ;;; Replace old data for key with new data
  372. (define (dbm-replace dbm key data)
  373.   (dbm-error dbm (%dbm-store (dbm-record:dbm (check-dbm dbm)) key data 1)))
  374.  
  375.  
  376. ;;; Returns a string containing the key of first record in database
  377. (define-foreign %dbm-firstkey (database_first ((C DBM*) dbm))
  378.   string)
  379.  
  380. (define (dbm-firstkey dbm)
  381.   (dbm-error dbm (%dbm-firstkey (dbm-record:dbm (check-dbm dbm)))))
  382.  
  383. ;;; Returns a string containing the key of the next sequential
  384. ;;; record on the database since the last firstkey or nextkey
  385. ;;; operation.  Records are returned in some arbitrary sequence.
  386. (define-foreign %dbm-nextkey (database_next ((C DBM*) dbm))
  387.   string)
  388.  
  389. (define (dbm-nextkey dbm)
  390.   (dbm-error dbm (%dbm-nextkey (dbm-record:dbm (check-dbm dbm)))))
  391.